home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / share / mc / extfs / uzip < prev    next >
Text File  |  2009-10-25  |  15KB  |  472 lines
  1. #! /usr/bin/perl -w
  2. #
  3. # zip file archive Virtual File System for Midnight Commander
  4. # Version 1.4.0 (2001-08-07).
  5. #
  6. # (C) 2000-2001  Oskar Liljeblad <osk@hem.passagen.se>.
  7. #
  8.  
  9. use POSIX;
  10. use File::Basename;
  11. use strict;
  12.  
  13. #
  14. # Configuration options
  15. #
  16.  
  17. # Location of the zip program
  18. my $app_zip = "/usr/bin/zip";
  19. # Location of the unzip program
  20. my $app_unzip = "/usr/bin/unzip";
  21. # Set this to 1 if zipinfo (unzip -Z) is to be used (recommended), otherwise 0.
  22. my $op_has_zipinfo = 0;
  23.  
  24. # Command used to list archives (zipinfo mode)
  25. my $cmd_list_zi = "$app_unzip -Z -l -T";
  26. # Command used to list archives (non-zipinfo mode)
  27. my $cmd_list_nzi = "$app_unzip -qq -v";
  28. # Command used to add a file to the archive
  29. my $cmd_add = "$app_zip -g";
  30. # Command used to add a link file to the archive (unused)
  31. my $cmd_addlink = "$app_zip -g -y";
  32. # Command used to delete a file from the archive
  33. my $cmd_delete = "$app_zip -d";
  34. # Command used to extract a file to standard out
  35. my $cmd_extract = "$app_unzip -p";
  36.  
  37. # -rw-r--r--  2.2 unx     2891 tx     1435 defN 20000330.211927 ./edit.html
  38. # (perm) (?) (?) (size) (?) (zippedsize) (method) (yyyy)(mm)(dd)(HH)(MM) (fname)
  39. my $regex_zipinfo_line = qr"^(\S{7,10})\s+(\d+\.\d+)\s+(\S+)\s+(\d+)\s+(\S\S)\s+(\d+)\s+(\S{4})\s+(\d{4})(\d\d)(\d\d)\.(\d\d)(\d\d)(\d\d)\s(.*)$";
  40.  
  41. #     2891  Defl:N     1435  50%  03-30-00 21:19  50cbaaf8  ./edit.html
  42. # (size) (method) (zippedsize) (zipratio) (mm)(dd)(yy)(HH)(MM) (cksum) (fname)
  43. my $regex_nonzipinfo_line = qr"^\s*(\d+)\s+(\S+)\s+(\d+)\s+(-?\d+\%)\s+(\d?\d)-(\d?\d)-(\d\d)\s+(\d?\d):(\d\d)\s+([0-9a-f]+)\s\s(.*)$";
  44.  
  45. #
  46. # Main code
  47. #
  48.  
  49. die "uzip: missing command and/or archive arguments\n" if ($#ARGV < 1);
  50.  
  51. # Initialization of some global variables
  52. my $cmd = shift;
  53. my %known = ( './' => 1 );
  54. my %pending = ();
  55. my $oldpwd = POSIX::getcwd();
  56. my $archive = shift;
  57. my $aarchive = absolutize($archive, $oldpwd);
  58. my $cmd_list = ($op_has_zipinfo ? $cmd_list_zi : $cmd_list_nzi);
  59. my ($qarchive, $aqarchive) = map (quotemeta, $archive, $aarchive);
  60.  
  61. # Strip all "." and ".." path components from a pathname.
  62. sub zipfs_canonicalize_pathname($) {
  63.   my ($fname) = @_;
  64.   $fname =~ s,/+,/,g;
  65.   $fname =~ s,(^|/)(?:\.?\./)+,$1,;
  66.   return $fname;
  67. }
  68.  
  69. # The Midnight Commander never calls this script with archive pathnames
  70. # starting with either "./" or "../". Some ZIP files contain such names,
  71. # so we need to build a translation table for them.
  72. my $zipfs_realpathname_table = undef;
  73. sub zipfs_realpathname($) {
  74.     my ($fname) = @_;
  75.  
  76.     if (!defined($zipfs_realpathname_table)) {
  77.         $zipfs_realpathname_table = {};
  78.     if (!open(ZIP, "$cmd_list $qarchive |")) {
  79.         return $fname;
  80.     }
  81.     foreach my $line (<ZIP>) {
  82.         $line =~ s/\r*\n*$//;
  83.         if ($op_has_zipinfo) {
  84.         if ($line =~ $regex_zipinfo_line) {
  85.             my ($fname) = ($14);
  86.             $zipfs_realpathname_table->{zipfs_canonicalize_pathname($fname)} = $fname;
  87.         }
  88.         } else {
  89.         if ($line =~ $regex_nonzipinfo_line) {
  90.             my ($fname) = ($11);
  91.             $zipfs_realpathname_table->{zipfs_canonicalize_pathname($fname)} = $fname;
  92.         }
  93.         }
  94.     }
  95.     if (!close(ZIP)) {
  96.         return $fname;
  97.     }
  98.     }
  99.     if (exists($zipfs_realpathname_table->{$fname})) {
  100.     return $zipfs_realpathname_table->{$fname};
  101.     }
  102.     return $fname;
  103. }
  104.  
  105. if ($cmd eq 'list')    { &mczipfs_list(@ARGV); }
  106. if ($cmd eq 'rm')      { &mczipfs_rm(@ARGV); }
  107. if ($cmd eq 'rmdir')   { &mczipfs_rmdir(@ARGV); }
  108. if ($cmd eq 'mkdir')   { &mczipfs_mkdir(@ARGV); }
  109. if ($cmd eq 'copyin')  { &mczipfs_copyin(@ARGV); }
  110. if ($cmd eq 'copyout') { &mczipfs_copyout(@ARGV); }
  111. if ($cmd eq 'run')         { &mczipfs_run(@ARGV); }
  112. #if ($cmd eq 'mklink')  { &mczipfs_mklink(@ARGV); }        # Not supported by MC extfs
  113. #if ($cmd eq 'linkout') { &mczipfs_linkout(@ARGV); }    # Not supported by MC extfs
  114. exit 1;
  115.  
  116. # Remove a file from the archive.
  117. sub mczipfs_rm {
  118.     my ($qfile) = map { &zipquotemeta(zipfs_realpathname($_)) } @_;
  119.  
  120.     # "./" at the beginning of pathnames is stripped by Info-ZIP,
  121.     # so convert it to "[.]/" to prevent stripping.
  122.     $qfile =~ s/^\\\./[.]/;
  123.  
  124.     &checkargs(1, 'archive file', @_);
  125.     &safesystem("$cmd_delete $qarchive $qfile >/dev/null");
  126.     exit;
  127. }
  128.  
  129. # Remove an empty directory from the archive.
  130. # The only difference from mczipfs_rm is that we append an 
  131. # additional slash to the directory name to remove. I am not
  132. # sure this is absolutely necessary, but it doesn't hurt.
  133. sub mczipfs_rmdir {
  134.     my ($qfile) = map { &zipquotemeta(zipfs_realpathname($_)) } @_;
  135.     &checkargs(1, 'archive directory', @_);
  136.     &safesystem("$cmd_delete $qarchive $qfile/ >/dev/null", 12);
  137.   exit;
  138. }
  139.  
  140. # Extract a file from the archive.
  141. # Note that we don't need to check if the file is a link,
  142. # because mc apparently doesn't call copyout for symbolic links.
  143. sub mczipfs_copyout {
  144.     my ($qafile, $qfsfile) = map { &zipquotemeta(zipfs_realpathname($_)) } @_;
  145.     &checkargs(1, 'archive file', @_);
  146.     &checkargs(2, 'local file', @_);
  147.     &safesystem("$cmd_extract $qarchive $qafile > $qfsfile", 11);
  148.   exit;
  149. }
  150.  
  151. # Add a file to the archive.
  152. # This is done by making a temporary directory, in which
  153. # we create a symlink the original file (with a new name).
  154. # Zip is then run to include the real file in the archive,
  155. # with the name of the symbolic link.
  156. # Here we also doesn't need to check for symbolic links,
  157. # because the mc extfs doesn't allow adding of symbolic
  158. # links.
  159. sub mczipfs_copyin {
  160.     my ($afile, $fsfile) = @_;
  161.     &checkargs(1, 'archive file', @_);
  162.     &checkargs(2, 'local file', @_);
  163.     my ($qafile) = quotemeta $afile;
  164.     $fsfile = &absolutize($fsfile, $oldpwd);
  165.     my $adir = File::Basename::dirname($afile);
  166.  
  167.     my $tmpdir = &mktmpdir();
  168.     chdir $tmpdir || &croak("chdir $tmpdir failed");
  169.     &mkdirs($adir, 0700);
  170.     symlink ($fsfile, $afile) || &croak("link $afile failed");
  171.     &safesystem("$cmd_add $aqarchive $qafile >/dev/null");
  172.     unlink $afile || &croak("unlink $afile failed");
  173.     &rmdirs($adir);
  174.     chdir $oldpwd || &croak("chdir $oldpwd failed");
  175.     rmdir $tmpdir || &croak("rmdir $tmpdir failed");
  176.   exit;
  177. }
  178.  
  179. # Add an empty directory the the archive.
  180. # This is similar to mczipfs_copyin, except that we don't need
  181. # to use symlinks.
  182. sub mczipfs_mkdir {
  183.     my ($dir) = @_;
  184.     &checkargs(1, 'directory', @_);
  185.     my ($qdir) = quotemeta $dir;
  186.  
  187.     my $tmpdir = &mktmpdir();
  188.     chdir $tmpdir || &croak("chdir $tmpdir failed");
  189.     &mkdirs($dir, 0700);
  190.     &safesystem("$cmd_add $aqarchive $qdir >/dev/null");
  191.     &rmdirs($dir);
  192.     chdir $oldpwd || &croak("chdir $oldpwd failed");
  193.     rmdir $tmpdir || &croak("rmdir $tmpdir failed");
  194.   exit;
  195. }
  196.  
  197. # Add a link to the archive. This operation is not used yet,
  198. # because it is not supported by the MC extfs.
  199. sub mczipfs_mklink {
  200.     my ($linkdest, $afile) = @_;
  201.     &checkargs(1, 'link destination', @_);
  202.     &checkargs(2, 'archive file', @_);
  203.     my ($qafile) = quotemeta $afile;
  204.     my $adir = File::Basename::dirname($afile);
  205.  
  206.     my $tmpdir = &mktmpdir();
  207.     chdir $tmpdir || &croak("chdir $tmpdir failed");
  208.     &mkdirs($adir, 0700);
  209.     symlink ($linkdest, $afile) || &croak("link $afile failed");
  210.     &safesystem("$cmd_addlink $aqarchive $qafile >/dev/null");
  211.     unlink $afile || &croak("unlink $afile failed");
  212.     &rmdirs($adir);
  213.     chdir $oldpwd || &croak("chdir $oldpwd failed");
  214.     rmdir $tmpdir || &croak("rmdir $tmpdir failed");
  215.   exit;
  216. }
  217.  
  218. # This operation is not used yet, because it is not
  219. # supported by the MC extfs.
  220. sub mczipfs_linkout {
  221.     my ($afile, $fsfile) = @_;
  222.     &checkargs(1, 'archive file', @_);
  223.     &checkargs(2, 'local file', @_);
  224.     my ($qafile) = map { &zipquotemeta($_) } $afile;
  225.  
  226.     my $linkdest = &get_link_destination($afile);
  227.     symlink ($linkdest, $fsfile) || &croak("link $fsfile failed");
  228.   exit;
  229. }
  230.  
  231. # Use unzip to find the link destination of a certain file in the
  232. # archive.
  233. sub get_link_destination {
  234.     my ($afile) = @_;
  235.     my ($qafile) = map { &zipquotemeta($_) } $afile;
  236.     my $linkdest = safeticks("$cmd_extract $qarchive $qafile");
  237.     &croak ("extract failed", "link destination of $afile not found")
  238.             if (!defined $linkdest || $linkdest eq '');
  239.     return $linkdest;
  240. }
  241.  
  242. # List files in the archive.
  243. # Because mc currently doesn't allow a file's parent directory
  244. # to be listed after the file itself, we need to do some
  245. # rearranging of the output. Most of this is done in
  246. # checked_print_file.
  247. sub mczipfs_list {
  248.     open (PIPE, "$cmd_list $qarchive |") || &croak("$app_unzip failed");
  249.     if ($op_has_zipinfo) {
  250.         while (<PIPE>) {
  251.             chomp;
  252.             next if /^Archive:/;
  253.             next if /^\d+ file/;
  254.             next if /^Empty zipfile\.$/;
  255.             my @match = /$regex_zipinfo_line/;
  256.             next if ($#match != 13);
  257.             &checked_print_file(@match);
  258.         }
  259.     } else {
  260.         while (<PIPE>) {
  261.             chomp;
  262.             my @match = /$regex_nonzipinfo_line/;
  263.             next if ($#match != 10);
  264.             my @rmatch = ('', '', 'unknown', $match[0], '', $match[2], $match[1],
  265.                     $match[6] + ($match[6] < 70 ? 2000 : 1900), $match[4], $match[5],
  266.                     $match[7], $match[8], "00", $match[10]);
  267.             &checked_print_file(@rmatch);
  268.         }
  269.     }
  270.     if (!close (PIPE)) {
  271.         &croak("$app_unzip failed") if ($! != 0);
  272.         &croak("$app_unzip failed", 'non-zero exit status ('.($? >> 8).')') 
  273.     }
  274.  
  275.     foreach my $key (sort keys %pending) {
  276.         foreach my $file (@{ $pending{$key} }) {
  277.             &print_file(@{ $file });
  278.         }
  279.     }
  280.  
  281.   exit;
  282. }
  283.  
  284. # Execute a file in the archive, by first extracting it to a
  285. # temporary directory. The name of the extracted file will be
  286. # the same as the name of it in the archive.
  287. sub mczipfs_run {
  288.     my ($afile) = @_;
  289.     &checkargs(1, 'archive file', @_);
  290.     my $qafile = &zipquotemeta(zipfs_realpathname($afile));
  291.     my $tmpdir = &mktmpdir();
  292.     my $tmpfile = File::Basename::basename($afile);
  293.  
  294.     chdir $tmpdir || &croak("chdir $tmpdir failed");
  295.     &safesystem("$cmd_extract $aqarchive $qafile > $tmpfile");
  296.   chmod 0700, $tmpfile;
  297.     &safesystem("./$tmpfile");
  298.     unlink $tmpfile || &croak("rm $tmpfile failed");
  299.     chdir $oldpwd || &croak("chdir $oldpwd failed");
  300.     rmdir $tmpdir || &croak("rmdir $tmpdir failed");
  301.   exit;
  302. }
  303.  
  304. # This is called prior to printing the listing of a file.
  305. # A check is done to see if the parent directory of the file has already
  306. # been printed or not. If it hasn't, we must cache it (in %pending) and
  307. # print it later once the parent directory has been listed. When all
  308. # files have been processed, there may still be some that haven't been 
  309. # printed because their parent directories weren't listed at all. These
  310. # files are dealt with in mczipfs_list.
  311. sub checked_print_file {
  312.     my @waiting = ([ @_ ]);
  313.  
  314.     while ($#waiting != -1) {
  315.         my $item = shift @waiting;
  316.         my $filename = ${$item}[13];
  317.         my $dirname = File::Basename::dirname($filename) . '/';
  318.  
  319.         if (exists $known{$dirname}) {
  320.             &print_file(@{$item});
  321.             if ($filename =~ /\/$/) {
  322.                 $known{$filename} = 1;
  323.                 if (exists $pending{$filename}) {
  324.                     push @waiting, @{ $pending{$filename} };
  325.                     delete $pending{$filename};
  326.                 }
  327.             }
  328.         } else {
  329.             push @{$pending{$dirname}}, $item;
  330.         }
  331.     }
  332. }
  333.  
  334. # Print the mc extfs listing of a file from a set of parsed fields.
  335. # If the file is a link, we extract it from the zip archive and
  336. # include the output as the link destination. Because this output
  337. # is not newline terminated, we must execute unzip once for each
  338. # link file encountered.
  339. sub print_file {
  340.     my ($perms,$zipver,$platform,$realsize,$format,$cmpsize,$comp,$year,$mon,$day,$hours,$mins,$secs,$filename) = @_;
  341.     if ($platform ne 'unx') {
  342.         $perms = ($filename =~ /\/$/ ? 'drwxr-xr-x' : '-rw-r--r--');
  343.     }
  344.     printf "%-10s    1 %-8d %-8d %8s %s/%s/%s %s:%s:%s %s", $perms, $<,
  345.         $(, $realsize, $mon, $day, $year, $hours, $mins, $secs, $filename;
  346.     if ($platform eq 'unx' && $perms =~ /^l/) {
  347.         my $linkdest = &get_link_destination($filename);
  348.         print " -> $linkdest";
  349.     }
  350.     print "\n";
  351. }
  352.  
  353. # Die with a reasonable error message.
  354. sub croak {
  355.     my ($command, $desc) = @_;
  356.     die "uzip ($cmd): $command - $desc\n" if (defined $desc);
  357.     die "uzip ($cmd): $command - $!\n";
  358. }
  359.  
  360. # Make a set of directories, like the command `mkdir -p'.
  361. # This subroutine has been tailored for this script, and
  362. # because of that, it ignored the directory name '.'.
  363. sub mkdirs {
  364.     my ($dirs, $mode) = @_;
  365.     $dirs = &cleandirs($dirs);
  366.     return if ($dirs eq '.');
  367.  
  368.     my $newpos = -1;
  369.     while (($newpos = index($dirs, '/', $newpos+1)) != -1) {
  370.         my $dir = substr($dirs, 0, $newpos);
  371.         mkdir ($dir, $mode) || &croak("mkdir $dir failed");
  372.     }
  373.     mkdir ($dirs, $mode) || &croak("mkdir $dirs failed");
  374. }
  375.  
  376. # Remove a set of directories, failing if the directories
  377. # contain other files.
  378. # This subroutine has been tailored for this script, and
  379. # because of that, it ignored the directory name '.'.
  380. sub rmdirs {
  381.     my ($dirs) = @_;
  382.     $dirs = &cleandirs($dirs);
  383.     return if ($dirs eq '.');
  384.  
  385.     rmdir $dirs || &croak("rmdir $dirs failed");
  386.     my $newpos = length($dirs);
  387.     while (($newpos = rindex($dirs, '/', $newpos-1)) != -1) {
  388.         my $dir = substr($dirs, 0, $newpos);
  389.         rmdir $dir || &croak("rmdir $dir failed");
  390.     }
  391. }
  392.  
  393. # Return a semi-canonical directory name.
  394. sub cleandirs {
  395.     my ($dir) = @_;
  396.     $dir =~ s:/+:/:g;
  397.     $dir =~ s:/*$::;
  398.     return $dir;
  399. }
  400.  
  401. # Make a temporary directory with mode 0700.
  402. sub mktmpdir {
  403.     use File::Temp qw(mkdtemp);
  404.     my $template = "/tmp/mcuzipfs.XXXXXX";
  405.     $template="$ENV{MC_TMPDIR}/mcuzipfs.XXXXXX" if ($ENV{MC_TMPDIR});
  406.     return mkdtemp($template);
  407. }
  408.  
  409. # Make a filename absolute and return it.
  410. sub absolutize {
  411.     my ($file, $pwd) = @_;
  412.     return "$pwd/$file" if ($file !~ /^\//);
  413.     return $file;
  414. }
  415.  
  416. # Like the system built-in function, but with error checking.
  417. # The other argument is an exit status to allow.
  418. sub safesystem {
  419.     my ($command, @allowrc) = @_;
  420.     my ($desc) = ($command =~ /^([^ ]*) */);
  421.     $desc = File::Basename::basename($desc);
  422.     system $command;
  423.     my $rc = $?;
  424.     &croak("`$desc' failed") if (($rc & 0xFF) != 0);
  425.     if ($rc != 0) {
  426.         $rc = $rc >> 8;
  427.         foreach my $arc (@allowrc) {
  428.             return if ($rc == $arc);
  429.         }
  430.         &croak("`$desc' failed", "non-zero exit status ($rc)");
  431.     }
  432. }
  433.  
  434. # Like backticks built-in, but with error checking.
  435. sub safeticks {
  436.     my ($command, @allowrc) = @_;
  437.     my ($desc) = ($command =~ /^([^ ]*) /);
  438.     $desc = File::Basename::basename($desc);
  439.     my $out = `$command`;
  440.     my $rc = $?;
  441.     &croak("`$desc' failed") if (($rc & 0xFF) != 0);
  442.     if ($rc != 0) {
  443.         $rc = $rc >> 8;
  444.         foreach my $arc (@allowrc) {
  445.             return if ($rc == $arc);
  446.         }
  447.         &croak("`$desc' failed", "non-zero exit status ($rc)");
  448.     }
  449.     return $out;
  450. }
  451.  
  452. # Make sure enough arguments are supplied, or die.
  453. sub checkargs {
  454.     my $count = shift;
  455.     my $desc = shift;
  456.     &croak('missing argument', $desc) if ($count-1 > $#_);
  457. }
  458.  
  459. # Quote zip wildcard metacharacters. Unfortunately Info-ZIP zip and unzip
  460. # on unix interpret some wildcards in filenames, despite the fact that
  461. # the shell already does this. Thus this function.
  462. sub zipquotemeta {
  463.     my ($name) = @_;
  464.     my $out = '';
  465.     for (my $c = 0; $c < length $name; $c++) {
  466.         my $ch = substr($name, $c, 1);
  467.         $out .= '\\' if (index('*?[]\\', $ch) != -1);
  468.         $out .= $ch;
  469.     }
  470.     return quotemeta($out);
  471. }
  472.